MacWorld 1997 September/Macworld (1997-09).dmg/Shareware World/Utilities/Text Processing/Alpha/Tcl/SystemCode/library.tcl

Text File | 1997-03-26 | 5KB | 189 lines

# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# $Header: /rel/cvsfiles/devo/tcl/library/init.tcl,v 1.2 1992/12/23 15:39:29 zoo Exp $ SPRITE (Berkeley)
#
# Copyright 1991-1992 Regents of the University of California
# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies.  The University of California
# makes no representations about the suitability of this
# software for any purpose.  It is provided "as is" without
# express or implied warranty.
#

# unknown:
# Invoked when a Tcl command is invoked that doesn't exist in the
# interpreter:
#
#    1. See if the autoload facility can locate the command in a
#       Tcl script file.  If so, load it and execute it.
#    2. See if the command exists as an executable UNIX program.
#       If so, "exec" the command.
#    3. If the command was invoked at top-level:
#        (a) see if the command requests csh-like history substitution
#        in one of the common forms !!, !<number>, or ^old^new.  If
#        so, emulate csh's history substitution.
#        (b) see if the command is a unique abbreviation for another
#        command.  If so, invoke the command.

proc unknown args {
    global auto_noload env unknown_pending;

    set name [lindex $args 0]

    if {[string length [set f [findCmd $name]]]} {
        uplevel #0 source [list $f]
        return [uplevel $args]
    } else {
        error "No such function: $name"
    }
}

# auto_mkindex:
# Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
# the name of the directory in which the tclIndex file is to be placed,
# and a glob pattern to use in that directory to locate all of the relevant
# files.
proc auto_mkindex {dir files} {
    global alphaLite

    set oldDir [pwd]
    cd $dir
    append line "# Tcl autoload index file: each line identifies a file (nowrap)\n\n"
    append line "set [file tail [string trim [pwd] :]]_index \{\n"

    set cid [scancontext create]
    scanmatch $cid {^proc[     ]} {
        if {[regexp {^proc[     ]+([^     ]*)} $matchInfo(line) match procName]} {
            append line "$procName "
        }
    }

    foreach file [glob $files] {
        if {($file == "menusLite.tcl") && !$alphaLite} continue;
        watchCursor
        set f ""
        append line "\{[file tail $file] "
        message [file tail $file]
        set fid [open $file]
        scanfile $cid $fid
        close $fid
        append line "\}\n"
    }

    scancontext delete $cid

    append line "\}\n"
    set f [open tclIndexx w]
    puts $f $line nonewline
    close $f
    cd $oldDir

    foreach i [info vars {*_index}] {
        global $i
        unset $i
    }
}

proc findCmd cmd {
    global global auto_path

    foreach path $auto_path {
        if {![file exists $path]} continue
        set index "[file tail $path]_index"
        global $index
        if {![info exists $index]} {
            uplevel #0 source [list "$path:tclIndexx"]
        }
        if {[regexp "\{(\\w+.tcl)\[^\}\]* [quoteExpr $cmd] " [set $index] dummy file]} {
            return "$path:$file"
        }
    }
}


#================================================================================
# Wonderful procs from Vince Darley ([e-mail]).
#===============================================================================

proc traceTclProc {} {
    global tclMenu
    if {[llength [traceFunc status]]>2} {
        catch {markMenuItem $tclMenu {traceTclProc…} off}
        catch {enableMenuItem $tclMenu dumpTraces off}
        if {[string length [set data [traceDump]]]} {
            if {[askyesno "Dump traces?"] == "yes"} {
                dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
                setWinInfo dirty 0
            }
        }
        traceFunc off
        message "Tracing off."
        return
    }
    if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
        set func [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
    } else {
        set func [listpick -p {Func Name:} [lsort -ignore [info procs]]]
    }
    if {![string length $func]} return
    traceFunc on $func ""
    catch {markMenuItem $tclMenu {traceTclProc…} on}
    catch {enableMenuItem $tclMenu dumpTraces on}
    message "Tracing '$func'…"
}


proc dumpTraces {{name ""} {data ""}} {
    if {![string length $name]} {
        set name [string trimright [lindex [traceFunc status] 3] {,}]
    }
    if {![string length $data]} {
        set data [traceDump]
    }

    if {![string length $data]} {
        message "Trace buffer empty"
    } else {
        regsub -all {:} $name {.} name
        new -n "* Trace '$name' *"
        insertText $data
        setWinInfo dirty 0
        goto 0
    }
}


proc rebuildTclIndices {} {
    global auto_path
    set d [pwd]
    # do we really need the next line? Alpha's original uses it.
    cd
    foreach dir $auto_path {
        # if directory exists
        if { ![catch { cd $dir } ] } {
            # if there are any files
            if { ![catch { glob *.*tcl } ] } {
                message "Building [file tail $dir] index…"

                # if the '[incr tcl]' version exists, use that
                # use 'catch' also in case directory is write-protected
                if [catch { itcl_mkindex : *.*tcl } ] {
                    # else try the normal one
                    catch { auto_mkindex : *.*tcl }
                }
            }
        }
    }
    # redo the auto-mode-file connections (see "smarterSource.tcl")
    message "Building the mode-file dependency array"
    catch {autoModeFiles}
    message ""
    cd $d
}